home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Scale.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  4.2 KB  |  139 lines
  1. ;;;;
  2. ;;;;  S c a l e . s t k            -- Scale Class definition 
  3. ;;;; 
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;
  15. ;;;; This software is a derivative work of other copyrighted softwares; the
  16. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  17. ;;;;;
  18. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  19. ;;;;    Creation date: 30-Mar-1993 15:28
  20. ;;;; Last file update: 24-Aug-1995 09:15
  21.  
  22.  
  23. (require "Basics")
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;;;;
  27. ;;;; <Scale> class definition
  28. ;;;;
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. (define-class <Scale> (<Tk-simple-widget>)
  32.   ((active-background    :init-keyword   :active-background 
  33.             :accessor     active-background
  34.             :tk-name     activebackground
  35.             :allocation     :tk-virtual)
  36.    (big-increment    :init-keyword     :big-increment
  37.             :accessor     big-increment
  38.             :allocation     :tk-virtual
  39.             :tk-name     bigincrement)
  40.    (command        :init-keyword     :command 
  41.             :accessor     command 
  42.             :allocation     :tk-virtual)
  43.    (digits        :init-keyword    :digits
  44.             :accessor    digits
  45.             :allocation    :tk-virtual)
  46.    (font         :init-keyword     :font 
  47.             :accessor     font 
  48.             :allocation      :tk-virtual)
  49.    (foreground         :init-keyword     :foreground 
  50.             :accessor     foreground 
  51.             :allocation     :tk-virtual)
  52.    (from         :init-keyword     :from 
  53.             :accessor     from 
  54.             :allocation     :tk-virtual)
  55.    (scale-length    :init-keyword    :scale-length 
  56.             :accessor     scale-length
  57.             :tk-name     length
  58.             :allocation     :tk-virtual)
  59.    (orientation     :init-keyword     :orientation
  60.             :accessor     orientation
  61.             :tk-name     orient
  62.             :allocation     :tk-virtual)
  63.    (repeat-delay     :init-keyword     :repeat-delay
  64.             :accessor     repeat-delay
  65.             :tk-name     repeatdelay
  66.             :allocation     :tk-virtual)
  67.    (repeat-interval     :init-keyword     :repeat-interval
  68.             :accessor     repeat-interval
  69.             :tk-name     repeatinterval
  70.             :allocation     :tk-virtual)
  71.    (resolution        :init-keyword    :resolution
  72.             :accessor    resolution
  73.             :allocation    :tk-virtual)
  74.    (show-value         :init-keyword     :show-value
  75.             :accessor     show-value
  76.             :tk-name     showvalue
  77.             :allocation     :tk-virtual)
  78.    (slider-length     :init-keyword    :slider-length 
  79.             :accessor    slider-length 
  80.             :tk-name    sliderlength
  81.             :allocation    :tk-virtual)
  82.    (state         :init-keyword    :state 
  83.             :accessor    state 
  84.             :allocation    :tk-virtual)
  85.    (text         :init-keyword     :text 
  86.             :accessor    text-of
  87.             :tk-name    label
  88.             :allocation     :tk-virtual)
  89.    (tick-interval    :init-keyword    :tick-interval
  90.             :accessor    tick-interval
  91.             :tk-name    tickinterval
  92.             :allocation    :tk-virtual)
  93.    (to             :init-keyword     :to 
  94.             :accessor     to 
  95.             :allocation     :tk-virtual)
  96.    (trough-color     :init-keyword     :trough-color
  97.             :accessor     trough-color
  98.             :tk-name     troughcolor
  99.             :allocation     :tk-virtual)
  100.    (variable        :init-keyword     :variable 
  101.             :accessor     variable
  102.             :allocation     :tk-virtual)
  103.    (width         :init-keyword     :width 
  104.             :accessor     width 
  105.             :allocation     :tk-virtual)
  106.    ;; Fictive slot 
  107.    (value        :accessor         value
  108.             :init-keyword     :value
  109.             :allocation       :virtual
  110.             :slot-ref         (lambda (o)  
  111.                       ((slot-ref o 'Id) 'get))
  112.             :slot-set!        (lambda (o v) 
  113.                       ((slot-ref o 'Id) 'set v)))))
  114.  
  115. (define-method tk-constructor ((self <Scale>))
  116.   Tk:scale)
  117.  
  118. ;;;
  119. ;;;  <Scale> methods
  120. ;;;
  121.  
  122. (define-method initialize ((self <Scale>) initargs)
  123.   (next-method)
  124.   (let* ((val (get-keyword :value initargs #f)))
  125.     ;; If a value is specified upon init, set it.
  126.     (when val
  127.       (slot-set! self 'value val))))
  128.  
  129. (define-method coords ((self <Scale>) . value)
  130.   (apply (slot-ref self 'Id) 'coords value))
  131.  
  132. (define-method get ((self <Scale>) x y)
  133.   ((slot-ref self 'Id) 'coords x y))
  134.  
  135. (define-method identify ((self <Scale>) x y)
  136.   ((slot-ref self 'Id) 'identify x y))
  137.  
  138.  
  139. (provide "Scale")